home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / mvpforth.arc / MVPSEDIT.FTH < prev    next >
Text File  |  1984-01-08  |  19KB  |  1,525 lines
  1. ( Henry Laxen's Screen EDITOR - ACKNOWLEDGEMENTS      31Oct83RSW
  2. )  10 LIST  11 LOAD  EXIT
  3.  
  4.     This screen editor is based on an article in
  5. Dr. Dobb's Journal, Number 59, September 1981, page 27
  6. by Henry Laxen.  It has been adapted for the IBM-PC
  7. (or equivalent) running MVP-FORTH version 1.0305.03 by
  8. R.S. White, Marion, IA.
  9.      It is R.S. White's understanding that this editor is in
  10. the public domain for non-commercial use only!  Any commerical
  11. use or sales of this editor should be arranged by
  12. contacting:
  13.       Henry Laxen
  14.       1259 Cornell Ave.
  15.       Berkeley, CA. 94706
  16.       (415) 525-8582
  17. ( LOAD SCREEN FOR SYSTEM GENERATION                  29Oct83 RSW
  18. )
  19.  
  20.  
  21.     24 LOAD     ( LOAD GENERAL PURPOSE STUFF )
  22.     38 LOAD     ( LOAD THE EDITOR )
  23.  
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31.  
  32.  
  33. FORTH Development System Documentation                01Nov83RSW
  34.  
  35.  
  36.    The FORTH editor is easy to learn and to use. It consists of
  37. control key ( or special function key ) commands that allow
  38. cursor movement and text entry and deletion so that editing can
  39. be done quickly and smoothly.
  40.  
  41. CURSOR MOVEMENT
  42.  
  43.    You can place the cursor anywhere on the screen by using a
  44. few editing commands.
  45.  
  46.    The following table describes the commands that are relevant
  47. to cursor movement.
  48.  
  49. CURSOR MOVEMENT COMMANDS                              01Nov83RSW
  50.  
  51.  
  52.  
  53.  
  54.  
  55.  
  56.  
  57.  
  58.  
  59.  
  60.  
  61.  
  62.  
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70.  
  71.  
  72.  
  73.  
  74.  
  75.  
  76.  
  77.  
  78.  
  79.  
  80.  
  81.  
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  
  223.  
  224.  
  225. ( \    COMMENT TO END OF LINE                       29Oct83 RSW
  226. )
  227.  
  228.   CR CR ." Most of the general purpose stuff is already "
  229.   CR    ." availible from MVP-FORTH binary image. " CR
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.   -->
  239.  
  240.  
  241. \  (S  (P  DOCUMEMTATION WORDS                        06Nov83RSW
  242.  
  243. : (S           ( --- )
  244.    41 WORD DROP ;
  245.    IMMEDIATE
  246.  
  247. : (P           ( --- )
  248.    41 WORD DROP ;
  249.    IMMEDIATE
  250.  
  251.  
  252.  -->
  253.  
  254.  
  255.  
  256.  
  257. \ SC@  fetch scan code byte of last key hit, IBM-PC   31Oct83RSW
  258.       HEX
  259. : SC@   ( --- scan-code ) \ fetch scan code of last key hit
  260.         40 DUP 1C @L    ( next-buf-addr --- )
  261.         20 MOD 1F +     ( prev-scan-code-buff-addr --- )
  262.         C@L ;           ( last-scan-code-byte --- )
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.                         DECIMAL -->
  271.  
  272.  
  273. \ L     INTELLIGENT SCREEN LISTER                    229Oct83RSW
  274.  
  275.  
  276. : L     ( (S [N] --- )
  277.    DEPTH IF
  278.     DUP SCR !
  279.    ELSE
  280.     SCR @
  281.    THEN
  282.    LIST ;
  283.  
  284.  
  285.   -->
  286.  
  287.  
  288.  
  289. \       BEEP
  290.  
  291.  
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  
  298.  
  299. : BEEP
  300.     7 EMIT ;
  301.  
  302.  
  303.   -->
  304.  
  305. \  BOUNDS      DO LOOP SETUP                    28Oct83 RSW
  306.  
  307. : BOUNDS    (  (S ADDR LEN --- ADDR+LEN ADDR )
  308.      OVER + SWAP ;
  309.  
  310.  -->
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321. \
  322.    -->
  323.  
  324.  
  325.  
  326.  
  327.  
  328.  
  329.  
  330.  
  331.  
  332.  
  333.  
  334.  
  335.  
  336.  
  337. \
  338.    -->
  339.  
  340.  
  341.  
  342.  
  343.  
  344.  
  345.  
  346.  
  347.  
  348.  
  349.  
  350.  
  351.  
  352.  
  353. \
  354.    -->
  355.  
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  
  362.  
  363.  
  364.  
  365.  
  366.  
  367.  
  368.  
  369. \
  370.   -->
  371.  
  372.  
  373.  
  374.  
  375.  
  376.  
  377.  
  378.  
  379.  
  380.  
  381.  
  382.  
  383.  
  384.  
  385. \
  386.   -->
  387.  
  388.  
  389.  
  390.  
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.  
  399.  
  400.  
  401. \  >=   <>  U> CONDITIONALS                     28Oct83 RSW
  402.  
  403. : >=  ( (S N1 N2 --- BOOL )
  404.  < 0= ;
  405.  
  406. : <>
  407.   = 0= ;
  408.  
  409. : <=
  410.    > 0= ;
  411.  
  412. : U>
  413.    SWAP U< ;
  414.  
  415.    -->
  416.  
  417. \ RE-FORTH   RE-ENTER FORTH FOR 1 LINE           28Oct83 RSW
  418.  
  419. : RE-FORTH    ( (S --- ??? )
  420.    >IN @ >R
  421.    BLK @ >R
  422.    0 >IN ! 0 BLK !
  423.    QUERY INTERPRET
  424.    R> BLK !
  425.    R> >IN ! ;
  426.  
  427.  
  428.  
  429.  
  430.  
  431.  
  432.      -->
  433. \
  434.  
  435.  
  436.  
  437.  
  438.  
  439.  
  440.  
  441.  
  442.  
  443.  
  444.  
  445.  
  446.  
  447.  
  448.  
  449. \ CASE:
  450.  
  451. : CASE:    ( (S N --- )
  452.    CREATE  ] SMUDGE
  453.    DOES>
  454.     SWAP 2* + @
  455.     EXECUTE ;
  456.  
  457.  
  458.  
  459.  
  460.  
  461.  
  462.      -->
  463.  
  464.  
  465. \  -TIDY                                       28Oct83 RSW
  466.  
  467. : -TIDY  ( (S ADDR LEN --- )
  468.    BOUNDS DO
  469.     I C@ BL < IF
  470.      BL I C!
  471.     THEN
  472.    LOOP ;
  473.  
  474.     BASE @ DECIMAL
  475. 1024 CONSTANT B/BUF    \ MVPFORTH BYTES-PER-BUFFER
  476. 1 CONSTANT B/SCR       \ MVPFORTH BLOCKS-PER-SCREEN
  477.      BASE !    \ RESTORE PRESENT BASE
  478.  
  479.    -->
  480.  
  481. \ VARIABLE AND CONSTANT DEFINITIONS               28OCT83 RSW
  482.  VOCABULARY EDIT IMMEDIATE EDIT DEFINITIONS
  483. VARIABLE &MODE  0 &MODE !
  484. VARIABLE &CURSOR  0 &CURSOR !
  485. VARIABLE &OLD-MODE  0 &OLD-MODE !
  486. VARIABLE &UPDATE  0 &UPDATE !
  487. VARIABLE &BUF-ADR  0 &BUF-ADR !
  488. VARIABLE &E-ID
  489.  12 ALLOT
  490.  &E-ID 14 BLANK
  491.  
  492. 5 CONSTANT %X-OFF
  493. 2 CONSTANT %Y-OFF
  494.  B/SCR B/BUF * CONSTANT C/SCR    \ CHARS PER SCREEN
  495.  C/SCR C/L /   CONSTANT L/SCR    \ LINES PER SCREEN
  496.   -->
  497. \ CURSOR POSITIONING VECTORS                        29Oct83 RSW
  498.  
  499. VARIABLE 'CRTXY
  500. VARIABLE 'CRTCLR-SCR
  501. VARIABLE 'CLEAR-TO-EOL
  502.  
  503. : CRTXY   ( (S X Y --- )
  504.    'CRTXY @ EXECUTE ;
  505.  
  506. : CRTCLR-SCR
  507.    'CRTCLR-SCR @ EXECUTE ;
  508.  
  509. : CLEAR-TO-EOL   ( (S col --- )
  510.    'CLEAR-TO-EOL @ EXECUTE ;
  511.    -->
  512.  
  513. \ DESCRIPTION OF CURSOR COMMANDS
  514.   -->
  515.  
  516.  
  517.  
  518.  
  519.  
  520.  
  521.  
  522.  
  523.  
  524.  
  525.  
  526.  
  527.  
  528.  
  529. \ DESC CONTINUED
  530.     -->
  531.  
  532.  
  533.  
  534.  
  535.  
  536.  
  537.  
  538.  
  539.  
  540.  
  541.  
  542.  
  543.  
  544.  
  545. \ DESC CONTINUED
  546.    -->
  547.  
  548.  
  549.  
  550.  
  551.  
  552.  
  553.  
  554.  
  555.  
  556.  
  557.  
  558.  
  559.  
  560.  
  561. \ CURPOS +CURPOS   MOVE-CURSOR                      29Oct83 RSW
  562. : CURPOS
  563.    &CURSOR @ ;
  564.  
  565. : +CURPOS
  566.    &CURSOR +!
  567.    CURPOS 0 MAX
  568.    [ C/SCR 1- ] LITERAL
  569.    MIN &CURSOR ! ;
  570.  
  571. : MOVE-CURSOR
  572.    +CURPOS
  573.    CURPOS C/L /MOD
  574.    %Y-OFF + SWAP
  575.    %X-OFF + SWAP
  576.    CRTXY ;    -->
  577. \ BUF-ADR
  578.  
  579. : BUF-ADR
  580.    &BUF-ADR @ + ;
  581.  
  582. : BUFPOS
  583.   CURPOS BUF-ADR ;
  584.  
  585.   -->
  586.  
  587.  
  588.  
  589.  
  590.  
  591.  
  592.  
  593. \ E-UPDATE
  594. : E-UPDATE
  595.    1 &UPDATE ! ;
  596.  
  597.   -->
  598.  
  599.  
  600.  
  601.  
  602.  
  603.  
  604.  
  605.  
  606.  
  607.  
  608.  
  609. \ BUF-MOVE
  610.  
  611. : BUF-MOVE
  612.    ROT BUF-ADR
  613.    ROT BUF-ADR
  614.    ROT BMOVE        \ MVPFORTH SPEC
  615.    E-UPDATE ;
  616.  
  617.      -->
  618.  
  619.  
  620.  
  621.  
  622.  
  623.  
  624.  
  625. \ ?PRINTABLE
  626. : ?PRINTABLE
  627.    DUP 32 <
  628.    SWAP 126 >
  629.    OR 0= ;
  630.  
  631.      -->
  632.  
  633.  
  634.  
  635.  
  636.  
  637.  
  638.  
  639.  
  640.  
  641. \ >LINE# LINE#
  642. : >LINE#
  643.    C/L / ;
  644.  
  645. : LINE#>
  646.    C/L * ;
  647.  
  648.      -->
  649.  
  650.  
  651.  
  652.  
  653.  
  654.  
  655.  
  656.  
  657. \ CHAR-TO-EOL
  658. : CHARS-TO-EOL
  659.    C/L MOD
  660.    C/L SWAP - ;
  661.  
  662.      -->
  663.  
  664.  
  665.  
  666.  
  667.  
  668.  
  669.  
  670.  
  671.  
  672.  
  673. \ DISPLAY-TO-EOL                                      29Oct83RSW
  674.  
  675. : DISPLAY-TO-EOL   ( (S POS --- )
  676.    DUP BUF-ADR          \ GET ADDRESS IN BUFFER
  677.    OVER CHARS-TO-EOL    \ REST OF LINE
  678.    -TRAILING            \ IGNORE BLANKS
  679.    ROT OVER + >R        \ SAVE RESULTANT CURSOR POSITION
  680.   TYPE                  \ DISPLAY WHATS THERE
  681.   R> CLEAR-TO-EOL       \ AND REMOVE THE REST
  682.   ;
  683.  
  684. ( (P DISPLAY-TO-EOL DISPLAYS THE REST OF THE LINE STARTING FROM
  685. THE CURRENT CURSOR POSITION.  IT ASSUMES THAT THE TERMINAL
  686. CURSOR IS PROPERLY POSITIONED BEFORE IT EXECUTES. )
  687.  
  688.       -->
  689. \ ?EMPTY-LINE
  690. : ?EMPTY-LINE
  691.    LINE#> BUF-ADR C/L
  692.    -TRAILING
  693.   SWAP DROP 0=
  694.   ;
  695.  
  696.        -->
  697.  
  698.  
  699.  
  700.  
  701.  
  702.  
  703.  
  704.  
  705. \ DISPLAY-TO-EOS
  706. : DISPLAY-TO-EOS
  707.    CURPOS SWAP
  708.    L/SCR SWAP DO
  709.     I LINE#>
  710.     DUP &CURSOR !
  711.     0 MOVE-CURSOR
  712.     DISPLAY-TO-EOL
  713.    LOOP
  714.    &CURSOR !
  715.    0 MOVE-CURSOR ;
  716.  
  717.        -->
  718.  
  719.  
  720.  
  721. \ EXPAND
  722.  
  723. : EXPAND
  724.    DUP DUP
  725.    C/L +
  726.    C/SCR OVER -
  727.    BUF-MOVE
  728.    BUF-ADR C/L BLANK
  729.    E-UPDATE ;
  730.  
  731.        -->
  732.  
  733.  
  734.  
  735.  
  736.  
  737. \ SHRINK
  738.  
  739. : SHRINK
  740.    DUP
  741.    C/L + SWAP
  742.    OVER C/SCR SWAP -
  743.    BUF-MOVE
  744.    [ L/SCR 1- ] LITERAL
  745.    LINE#> BUF-ADR C/L BLANK
  746.    E-UPDATE ;
  747.  
  748.       -->
  749.  
  750.  
  751.  
  752.  
  753. \ INSERT-LINE
  754.  
  755. : INSERT-LINE
  756.    [ L/SCR 1- ] LITERAL
  757.    ?EMPTY-LINE IF
  758.     DUP EXPAND
  759.     >LINE# DISPLAY-TO-EOS
  760.    ELSE
  761.     BEEP
  762.    THEN ;
  763.  
  764.      -->
  765.  
  766.  
  767.  
  768.  
  769. \ DELETE-LINE
  770.  
  771. : DELETE-LINE
  772.    >LINE# DUP LINE#> SHRINK
  773.    DISPLAY-TO-EOS ;
  774.  
  775.   -->
  776.  
  777.  
  778.  
  779.  
  780.  
  781.  
  782.  
  783.  
  784.  
  785. \ INS-CHAR
  786.  
  787. : INS-CHAR
  788.    DUP DUP 1+
  789.    OVER CHARS-TO-EOL 1-
  790.    BUF-MOVE
  791.    BUF-ADR C! ;
  792.  
  793.        -->
  794.  
  795.  
  796.  
  797.  
  798.  
  799.  
  800.  
  801. \ DEL-CHAR
  802.  
  803. : DEL-CHAR
  804.    DUP DUP 1+ SWAP
  805.    OVER CHARS-TO-EOL
  806.    BUF-MOVE
  807.    DUP CHARS-TO-EOL + 1-
  808.    BUF-ADR BL SWAP C! ;
  809.  
  810.      -->
  811.  
  812.  
  813.  
  814.  
  815.  
  816.  
  817. \ ARROW COMMANDS
  818.  
  819. : R-ARROW
  820.    1 +CURPOS ;
  821.  
  822. : L-ARROW
  823.    -1 +CURPOS ;
  824.  
  825. : U-ARROW
  826.    C/L NEGATE +CURPOS ;
  827.  
  828. : D-ARROW
  829.    C/L +CURPOS ;
  830.  
  831.      -->
  832.  
  833. \ I-LINE D-LINE D-CHAR INSERT-MODE                    29Oct83RSW
  834.  
  835. : I-LINE
  836.    CURPOS INSERT-LINE ;
  837.  
  838. : D-LINE
  839.    CURPOS DELETE-LINE ;
  840.  
  841. : D-CHAR
  842.    CURPOS DEL-CHAR
  843.    CURPOS DISPLAY-TO-EOL ;
  844.  
  845. : INSERT-MODE
  846.    &MODE 1 TOGGLE ;
  847.  
  848.       -->
  849. \ RETURN EXIT-EDIT                                    06Nov83RSW
  850.  
  851. : RETURN
  852.    CURPOS >LINE#
  853.    1+
  854.    [ L/SCR 1- ] LITERAL MIN
  855.    LINE#> &CURSOR ! ;
  856.  
  857. : EXIT-EDIT
  858.    CR ABORT ;
  859.     ( R> DROP R> DROP R> DROP R> DROP R> DROP ; ) \ fig version
  860.  
  861.       -->
  862.  
  863.  
  864.  
  865. \ EXIT-UPDATE
  866.  
  867. : EXIT-UPDATE
  868.    C/SCR MOVE-CURSOR
  869.    CR CR
  870.    SCR @ .
  871.    &UPDATE @ IF
  872.      &E-ID
  873.      [ C/L 10 - ] LITERAL
  874.      BUF-ADR 10 CMOVE
  875.      ." Modified" UPDATE FLUSH
  876.    ELSE ." Unmodified" THEN
  877.    EXIT-EDIT ;
  878.  
  879.      -->
  880.  
  881. \ EXIT-SCRATCH
  882.  
  883. : EXIT-SCRATCH
  884.    C/SCR MOVE-CURSOR
  885.    CR CR
  886.    SCR ?
  887.    ." Abandoned"
  888.    EXIT-EDIT ;
  889.  
  890.        -->
  891.  
  892.  
  893.  
  894.  
  895.  
  896.  
  897. \ E-TAB
  898.  
  899. : E-TAB
  900.    8 CURPOS 8 MOD -
  901.    +CURPOS ;
  902.  
  903.       -->
  904.  
  905.  
  906.  
  907.  
  908.  
  909.  
  910.  
  911.  
  912.  
  913. \ SCAN+=
  914. : SCAN+=
  915.    2DUP = IF
  916.      DROP 2DROP 0
  917.    ELSE
  918.      0 ROT ROT DO
  919.        OVER I C@ = IF
  920.          LEAVE
  921.        ELSE 1+ THEN
  922.      LOOP
  923.      SWAP DROP
  924.    THEN ;
  925.  
  926.         -->
  927.  
  928.  
  929. \ SCAN+<>
  930. : SCAN+<>
  931.    2DUP = IF
  932.      DROP 2DROP 0
  933.    ELSE
  934.      0 ROT ROT DO
  935.        OVER I C@ <> IF
  936.          LEAVE
  937.        ELSE 1+ THEN
  938.      LOOP
  939.      SWAP DROP
  940.    THEN ;
  941.  
  942.       -->
  943.  
  944.  
  945. \ SCAN-=
  946. : SCAN-=
  947.    2DUP = IF
  948.      DROP 2DROP 0
  949.    ELSE
  950.      0 ROT ROT DO
  951.        OVER I C@ = IF
  952.          LEAVE
  953.        ELSE 1- THEN
  954.      -1 +LOOP
  955.      SWAP DROP
  956.    THEN ;
  957.  
  958.       -->
  959.  
  960.  
  961. \ SCAN-<>
  962. : SCAN-<>
  963.    2DUP = IF
  964.      DROP 2DROP 0
  965.    ELSE
  966.      0 ROT ROT DO
  967.        OVER I C@ <> IF
  968.          LEAVE
  969.        ELSE 1- THEN
  970.      -1 +LOOP
  971.      SWAP DROP
  972.    THEN ;
  973.  
  974.       -->
  975.  
  976.  
  977. \ MOVE-LEFT-WORD
  978. : MOVE-LEFT-WORD
  979.     BL 0 BUF-ADR BUFPOS
  980.     SCAN-= >R
  981.     BL 0 BUF-ADR BUFPOS R@ +
  982.     SCAN-<> R> + >R
  983.     BL 0 BUF-ADR BUFPOS R@ +
  984.     SCAN-= R> +
  985.     DUP BUFPOS + C@ BL = IF
  986.      1+
  987.     THEN ;
  988.  
  989.          -->
  990.  
  991.  
  992.  
  993. \ MOVE-RIGHT-WORD
  994.  
  995. : MOVE-RIGHT-WORD
  996.    BL [ C/SCR 1- ] LITERAL BUF-ADR
  997.    BUFPOS SCAN+= >R
  998.    BL [ C/SCR 1- ] LITERAL BUF-ADR
  999.    BUFPOS R@ +
  1000.    SCAN+<> R> + ;
  1001.  
  1002.        -->
  1003.  
  1004.  
  1005.  
  1006.  
  1007.  
  1008.  
  1009. \ R-WORD L-WORD
  1010.  
  1011. : R-WORD
  1012.    MOVE-RIGHT-WORD
  1013.    +CURPOS ;
  1014.  
  1015. : L-WORD
  1016.    MOVE-LEFT-WORD
  1017.    +CURPOS ;
  1018.  
  1019.         -->
  1020.  
  1021.  
  1022.  
  1023.  
  1024.  
  1025. \ DEL-CHARS                                           29Oct83RSW
  1026.  
  1027. : DEL-CHARS     ( (S N POS --- )
  1028.    2DUP + OVER
  1029.    DUP CHARS-TO-EOL
  1030.    BUF-MOVE
  1031.    DUP CHARS-TO-EOL +
  1032.    OVER - BUF-ADR
  1033.    SWAP BLANK ;
  1034.  
  1035.        -->
  1036.  
  1037.  
  1038.  
  1039.  
  1040.  
  1041. \ D-WORD
  1042.  
  1043. : D-WORD
  1044.    MOVE-RIGHT-WORD
  1045.    CURPOS BUF-ADR
  1046.    CURPOS CHARS-TO-EOL
  1047.    -TRAILING SWAP DROP
  1048.    MIN CURPOS DEL-CHARS
  1049.    CURPOS DISPLAY-TO-EOL ;
  1050.  
  1051.          -->
  1052.  
  1053.  
  1054.  
  1055.  
  1056.  
  1057. \ U-TAB D-TAB CRL-SCREEN
  1058. : U-TAB
  1059.    4 C/L *
  1060.    NEGATE +CURPOS ;
  1061.  
  1062. : D-TAB
  1063.    4 C/L *
  1064.    +CURPOS ;
  1065.  
  1066. : CLR-SCREEN
  1067.    0 &CURSOR !
  1068.    CURPOS BUF-ADR
  1069.    C/SCR BLANK
  1070.    0 DISPLAY-TO-EOS
  1071.    E-UPDATE ;
  1072.              -->
  1073. \ DISPLAY-STATUS
  1074.  
  1075. : DISPLAY-STATUS
  1076.    &MODE @ &OLD-MODE @ <> IF
  1077.      40 0 CRTXY
  1078.      &MODE @ IF
  1079.        ." Insert ON"
  1080.      ELSE
  1081.        9 SPACES
  1082.      THEN
  1083.      &MODE @ &OLD-MODE !
  1084.    THEN
  1085.    CURPOS C/L /MOD
  1086.    35 0 CRTXY 2 .R
  1087.    28 0 CRTXY 2 .R ;
  1088.          -->
  1089. \ CLR-LINE
  1090.  
  1091. : CLR-LINE
  1092.    CURPOS DUP
  1093.    >LINE# LINE#> &CURSOR !
  1094.    CURPOS BUF-ADR
  1095.    C/L BLANK
  1096.    E-UPDATE
  1097.    0 MOVE-CURSOR
  1098.    CURPOS CLEAR-TO-EOL
  1099.    &CURSOR ! ;
  1100.  
  1101.        -->
  1102.  
  1103.  
  1104.  
  1105. \ GET-USER-ID
  1106.  
  1107. : GET-USER-ID
  1108.    &E-ID 10 -TRAILING 0= IF
  1109.      CR ." Enter Your ID: "
  1110.      10 0 DO 46 ( . ) EMIT LOOP
  1111.      10 0 DO 8 ( BS ) EMIT LOOP
  1112.      10 EXPECT
  1113.      &E-ID 10 -TIDY
  1114.    ELSE
  1115.     DROP
  1116.    THEN ;
  1117.  
  1118.          -->
  1119.  
  1120.  
  1121. \ CONTROL CHARACTER DEFINITIONS
  1122.  
  1123. CASE: (CONTROL-CHAR)
  1124.  
  1125.    BEEP        \ 0: c@ --- ERROR
  1126.    L-WORD
  1127.    CLR-LINE
  1128.    D-TAB
  1129.    R-ARROW
  1130.    U-ARROW
  1131.    R-WORD
  1132.    D-CHAR
  1133.    L-ARROW
  1134.    E-TAB
  1135.  -->
  1136.  
  1137. \ CONTROL CHAR DEF CONTINUED
  1138.  
  1139.      BEEP
  1140.      CLR-SCREEN
  1141.      BEEP
  1142.      RETURN
  1143.      I-LINE
  1144.      BEEP
  1145.      BEEP
  1146.      BEEP
  1147.      U-TAB
  1148.      L-ARROW
  1149.  -->
  1150.  
  1151.  
  1152.  
  1153. \ CONTROL CHAR DEF CONTINUED
  1154.  
  1155.    D-WORD
  1156.    BEEP
  1157.    INSERT-MODE
  1158.    BEEP
  1159.    D-ARROW
  1160.    D-LINE
  1161.    EXIT-SCRATCH
  1162.    EXIT-UPDATE      \ 27: ESC --- EXIT EDITOR NORMALLY
  1163.    ;
  1164.  
  1165.      -->
  1166.  
  1167.  
  1168.  
  1169. \ CONTROL-CHAR                                        31Oct83RSW
  1170.         -->
  1171. : CONTROL-CHAR          \ skipped for IBM version
  1172.    DUP 127 = IF
  1173.      DROP 8
  1174.    THEN
  1175.    DUP 28 < IF
  1176.      (CONTROL-CHAR)
  1177.    ELSE
  1178.      DROP BEEP
  1179.    THEN ;
  1180.  
  1181.     -->
  1182.  
  1183.  
  1184.  
  1185. \ special IBM PC key definitions                      06Nov83RSW
  1186.  
  1187. CASE: <IBM-KEY>
  1188.  
  1189.    I-LINE       \ 0;59 F1 --- INSERT LINE
  1190.    EXIT-UPDATE  \ 1;60 F2 --- EXIT EDITOR NORMALLY
  1191.    EXIT-SCRATCH \ 2;61 F3 --- ABANDON SCREEN
  1192.    CLR-SCREEN   \ 3;62 F4 --- CLEAR SCREEN
  1193.    BEEP         \ 4;63 F5 --- ERROR
  1194.    CLR-LINE     \ 5;64 F6 --- BLANK OUT CURRENT LINE
  1195.    D-WORD       \ 6;65 F7 --- DELETE CURRENT WORD
  1196.    D-LINE       \ 7;66 F8 --- DELETE CURRENT LINE
  1197.    L-WORD       \ 8;67 F9 --- MOVE TO NEXT WORD ON LEFT
  1198.    R-WORD       \ 9;68 F10 -- MOVE TO NEXT WORD ON RIGHT
  1199.    BEEP         \ 10;69   --- ERROR
  1200.  -->
  1201. \ special IBM PC keys continued                       31Oct83RSW
  1202.    BEEP         \ 11;70      --- ERROR
  1203.    BEEP         \ 12;71 Home --- ERROR
  1204.    U-ARROW      \ 13;72  ^   --- MOVE UP ONE LINE up-arrow
  1205.    U-TAB        \ 14;73 PgUp --- MOVE UP 4 LINES
  1206.    BEEP         \ 15;74      --- ERROR
  1207.    L-ARROW      \ 16;75 <--  --- MOVE LEFT ONE CHAR
  1208.    BEEP         \ 17;76      --- ERROR
  1209.    R-ARROW      \ 18;77 -->  --- MOVE RIGHT ONE CHAR
  1210.    BEEP         \ 19;78      --- ERROR
  1211.    BEEP         \ 20;79 End  --- ERROR
  1212.    D-ARROW      \ 21;80  v   --- MOVE DOWN ONE LINE down-arrow
  1213.    D-TAB        \ 22;81 PgDn --- MOVE DOWN 4 LINE
  1214.    INSERT-MODE  \ 23;82 Ins  --- TOGGLE INSERT MODE
  1215.    D-CHAR       \ 24;83 Del  --- DELETE CURRENT CHAR
  1216.    ;    -->
  1217. \ IBM-KEY  process special IBM PC edit keys           31Oct83RSW
  1218.  
  1219. : IBM-KEY  ( CHAR --- )
  1220.    DROP SC@             \ forget key code & fetch scan code
  1221.    DUP 58 > IF          \ in valid range?
  1222.      DUP 84 < IF        \   maybe - in valid range?
  1223.        59 - <IBM-KEY>   \            yes - process key
  1224.      ELSE
  1225.        DROP BEEP        \            no - complain
  1226.      THEN
  1227.    ELSE
  1228.      DROP BEEP          \   no - complain
  1229.    THEN ;       -->
  1230.  
  1231.  
  1232.  
  1233. \ CONTROL-CHAR                                        31Oct83RSW
  1234.  
  1235. : CONTROL-CHAR
  1236.    DUP 0= IF            \ special IBM key?
  1237.      IBM-KEY            \  yes - do it
  1238.    ELSE
  1239.      DUP 28 < IF        \  no - control key?
  1240.        (CONTROL-CHAR)   \         yes - do it
  1241.      ELSE
  1242.        DROP BEEP        \         no - complain
  1243.      THEN
  1244.    THEN ;       -->
  1245.  
  1246.  
  1247.  
  1248.  
  1249. \                                                     31Oct83RSW
  1250.                 -->
  1251.  
  1252.  
  1253.  
  1254.  
  1255.  
  1256.  
  1257.  
  1258.  
  1259.  
  1260.  
  1261.  
  1262.  
  1263.  
  1264.  
  1265. \                                                     31Oct83RSW
  1266.         -->
  1267.  
  1268.  
  1269.  
  1270.  
  1271.  
  1272.  
  1273.  
  1274.  
  1275.  
  1276.  
  1277.  
  1278.  
  1279.  
  1280.  
  1281. \                                                     31Oct83RSW
  1282.         -->
  1283.  
  1284.  
  1285.  
  1286.  
  1287.  
  1288.  
  1289.  
  1290.  
  1291.  
  1292.  
  1293.  
  1294.  
  1295.  
  1296.  
  1297. \                                                     31Oct83RSW
  1298.           -->
  1299.  
  1300.  
  1301.  
  1302.  
  1303.  
  1304.  
  1305.  
  1306.  
  1307.  
  1308.  
  1309.  
  1310.  
  1311.  
  1312.  
  1313. \                                                     31Oct83RSW
  1314.         -->
  1315.  
  1316.  
  1317.  
  1318.  
  1319.  
  1320.  
  1321.  
  1322.  
  1323.  
  1324.  
  1325.  
  1326.  
  1327.  
  1328.  
  1329. \                                                     31Oct83RSW
  1330.         -->
  1331.  
  1332.  
  1333.  
  1334.  
  1335.  
  1336.  
  1337.  
  1338.  
  1339.  
  1340.  
  1341.  
  1342.  
  1343.  
  1344.  
  1345. \ E-OVERSTRIKE
  1346.  
  1347. : E-OVERSTRIKE
  1348.    KEY DUP
  1349.    ?PRINTABLE IF
  1350.      DUP EMIT
  1351.      BUFPOS C!
  1352.      E-UPDATE
  1353.      1 +CURPOS
  1354.    ELSE
  1355.     CONTROL-CHAR
  1356.    THEN ;
  1357.  
  1358.        -->
  1359.  
  1360.  
  1361. \ E-INSERT
  1362.  
  1363. : E-INSERT
  1364.    KEY DUP
  1365.    ?PRINTABLE IF
  1366.      CURPOS INS-CHAR
  1367.      CURPOS DISPLAY-TO-EOL
  1368.      1 +CURPOS
  1369.    ELSE
  1370.      CONTROL-CHAR
  1371.    THEN ;
  1372.  
  1373.          -->
  1374.  
  1375.  
  1376.  
  1377. \ E-INIT
  1378.  
  1379. : E-INIT
  1380.    DEPTH IF SCR ! THEN
  1381.    SCR @ BLOCK &BUF-ADR !
  1382.    GET-USER-ID CRTCLR-SCR
  1383.    0 &MODE ! 0 &CURSOR !
  1384.    0 &UPDATE !
  1385.    0 %Y-OFF CRTXY
  1386.    L/SCR 0 DO
  1387.      I 3 .R CR
  1388.    LOOP
  1389.    10 0 CRTXY
  1390.    ." Scr: " SCR @ 4 .R 6 SPACES ." X=     Y="
  1391.    0 DISPLAY-TO-EOS ;
  1392.  -->
  1393. \ E
  1394.        FORTH DEFINITIONS
  1395. : E
  1396.    EDIT
  1397.    E-INIT
  1398.    BEGIN
  1399.      DISPLAY-STATUS
  1400.      0 MOVE-CURSOR
  1401.      &MODE @ IF
  1402.        E-INSERT
  1403.      ELSE
  1404.        E-OVERSTRIKE
  1405.      THEN
  1406.    AGAIN ;
  1407.  
  1408.         -->
  1409. \  CONFIGURE USER'S TERMINAL                          31Oct83RSW
  1410.  
  1411.  DECIMAL EDIT DEFINITIONS
  1412.  100 LOAD       \ ONLY CONFIGURE IBM-PC VIDEO FOR NOW
  1413.  FORTH DEFINITIONS DECIMAL
  1414.  CR ." Ready to Edit" CR CR
  1415.  
  1416.  
  1417.  
  1418.  
  1419.  
  1420.  
  1421.  
  1422.  
  1423.  
  1424.  
  1425.  
  1426.  
  1427.  
  1428.  
  1429.  
  1430.  
  1431.  
  1432.  
  1433.  
  1434.  
  1435.  
  1436.  
  1437.  
  1438.  
  1439.  
  1440.  
  1441. \ CURSOR COMMANDS FOR MVPFORTH/IBM-PC VERSION         29Oct83RSW
  1442.   HEX
  1443. CODE PC-CRTXY  ( (S  X Y --- )  \ POSITION IBM PC CURSOR
  1444.         AX              POP     \ FETCH Y INTO AL
  1445.         DX              POP     \ FETCH X INTO DL
  1446.         DH, AL          MOV     \ PUT Y INTO DH
  1447.         AH, # 2         MOV     \ AH=2 FOR CURSOR POS CMD
  1448.         BH, # 0         MOV     \ BH=0 FOR PAGE 0
  1449.         SI              PUSH    \ SAVE NECESSARY REGS
  1450.         BP              PUSH
  1451.         10              INT     \ DO IBM VIDEO ROM ROUTINE
  1452.         BP              POP     \ RECOVER REGS
  1453.         SI              POP
  1454.         NEXT            JMP  END-CODE  DECIMAL -->
  1455.  
  1456.  
  1457. \ CURSOR COMMANDS CONT.                               29Oct83RSW
  1458.   HEX
  1459. CODE <CLRSCR>  ( (S --- )       \ CLEAR ENTIRE IBM PC SCREEN
  1460.         AX, # 600       MOV     \ AH=6, AL=0 FOR BLANK SCROLL UP
  1461.         BH, # 7         MOV     \ BH=7 FOR NORMAL VIDEO
  1462.         DX, # 184F      MOV     \ DH=24D, DL=79D FOR BOT CORNER
  1463.         CX, # 0         MOV     \ CH=0, CL=0 FOR TOP CORNER
  1464.         SI              PUSH    \ SAVE NECCESARY REGS
  1465.         BP              PUSH
  1466.         10              INT     \ DO IBM VIDEO ROM ROUTINE
  1467.         BP              POP     \ RECOVER REGS
  1468.         SI              POP
  1469.         NEXT            JMP   END-CODE  DECIMAL -->
  1470.  
  1471.  
  1472.  
  1473. ( CURSOR COMMANDS CONT. ) HEX   \                     29Oct83RSW
  1474. CODE PC-CRTCLR-EOL  ( (S POS --- ) \ IBM PC CLEAR TO END OF LINE
  1475.         AX              POP     \ THROW AWAY COMPUTED POSITION
  1476.         AH, # 3         MOV     \ READ CURSOR ADDRESS CMD
  1477.         BH, # 0         MOV     \ PAGE 0 OF VIDEO
  1478.         SI PUSH  BP PUSH        \ SAVE NECESSARY REGS
  1479.         10              INT     \ DO IBM ROM BIOS ROUTINE
  1480.         DH, # 0         MOV     \ IGNORE ROW INFO
  1481.         CX, # 46        MOV     \ MAX = C/L + %XOFF
  1482.         CX, DX          SUB     \ CX = # OF CHARS LEFT ON LINE
  1483.       ( IF ELSE                 \ EXACTLY = ?           )
  1484.         AX, # 0A20      MOV     \ AH=10D, AL=' ' FOR VIDEO WRT
  1485.         BH, # 0         MOV     \ PAGE 0 OF VIDEO
  1486.         10              INT     \ DO IBM ROM BIOS ROUTINE
  1487.       ( ENDIF                   \  SKIPPED CODE IF EQUAL )
  1488.         BP POP  SI POP  NEXT JMP  END-CODE   DECIMAL -->
  1489. \ cursor & video for IBM-PC continued
  1490.       HEX
  1491. : PC-CLRSCR    <CLRSCR> 0 0 PC-CRTXY ;
  1492.  
  1493. ' PC-CRTXY         CFA 'CRTXY !
  1494. ' PC-CLRSCR        CFA 'CRTCLR-SCR !
  1495. ' PC-CRTCLR-EOL    CFA 'CLEAR-TO-EOL !
  1496.  
  1497.  DECIMAL 103 . ." done loading SCREEN EDITOR " CR BEEP
  1498.  
  1499. \ ******** end of Henry Laxen's EDITOR *************
  1500.  
  1501.  
  1502.  
  1503.  
  1504.  
  1505. \ _________________    F1-F10 special function keys   02Nov83RSW
  1506.   |insert |normal |
  1507.   | line 1|exit  2|    Esc -- normal exit
  1508.   -----------------
  1509.   |abandon| clear |    ^Z  -- abandon screen
  1510.   | scrn 3| scrn 4|
  1511.   -----------------    Ins -- toggle insert mode
  1512.   |       | blank |
  1513.   |      5| line 6|    Del -- delete character
  1514.   -----------------
  1515.   |delete |delete |   PgUp -- up 4 lines
  1516.   | word 7| line 8|
  1517.   -----------------   PgDn -- down 4 lines
  1518.   | left  |right  |
  1519.   | word 9|word 10|
  1520.   -----------------
  1521.  | word 7| line 8|
  1522.   -----------------   PgDn -- down 4 lines
  1523.   | left  |right  |
  1524.   | word 9|word 10|
  1525.